home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
root.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
13KB
|
522 lines
/* ******************************************************************** */
/* root.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* The root level operations */
/* ******************************************************************** */
/*
* Change Log:
* Version 1, March 1990 (Compiler rationalisation)
*/
#include <stdio.h>
#include <string.h>
#include "funcalls.h"
#include "defs.h"
#include "structs.h"
#include "error.h"
#include "global.h"
#include "slots.h"
#include "table.h"
#include "garbage.h"
#include "allocate.h"
#include "modboot.h"
#include "symboot.h"
#include "modules.h"
#include "toplevel.h"
#include "root.h"
#include "copy.h"
#define ROOT_ENTRIES 12
MODULE Module_root;
LispObject Module_root_values[ROOT_ENTRIES];
static SYSTEM_GLOBAL(LispObject,list_search_path);
static SYSTEM_GLOBAL(int,load_verbosity);
static LispObject sym_eval_cm,sym_set_cm;
EUFUN_2( eval_cm_template, env, form)
{
return(EUCALL_3(module_eval,env->ENV.value,NULL,form));
}
EUFUN_CLOSE
EUFUN_3( set_cm_template, env, sym, val)
{
if (!is_symbol(sym))
CallError(stacktop,"set/cm: not a symbol",sym,NONCONTINUABLE);
printf("No set/cm yet...\n");
(void) EUCALL_3(module_set,((Env)env)->value,sym,val);
return(val);
}
EUFUN_CLOSE
void make_default_module_functions(LispObject *stacktop,LispObject mod)
{
LispObject f;
STACK_TMP(mod);
f = make_anonymous_module_env_function_1(stacktop,mod,eval_cm_template,1,
sym_nil,mod);
UNSTACK_TMP(mod);
STACK_TMP(mod);
(void) module_set_new(stacktop,mod,sym_eval_cm,f);
UNSTACK_TMP(mod);
STACK_TMP(mod);
f = make_anonymous_module_env_function_1(stacktop,mod,set_cm_template,2,
sym_nil,mod);
UNSTACK_TMP(mod);
(void) module_set_new(stacktop,mod,sym_set_cm,f);
}
EUFUN_3( Rf_defmodule, mod, env, forms)
{
LispObject name,import_specs,syntax_specs;
LispObject module;
LispObject walker;
if (!is_cons(forms))
CallError(stacktop,"defmodule: missing name",nil,NONCONTINUABLE);
name = CAR(forms); forms = CDR(forms);
if (!is_symbol(name))
CallError(stacktop,"defmodule: non-symbolic name",name,NONCONTINUABLE);
/* Overwrite existing one... */ /* HACK !!! */
if (!is_cons(forms))
CallError(stacktop,"defmodule: missing import specs",nil,NONCONTINUABLE);
import_specs = CAR(forms); forms = CDR(forms);
if (!is_cons(import_specs) && import_specs != nil)
CallError(stacktop,
"defmodule: bad import spec",import_specs,NONCONTINUABLE);
if (!is_cons(forms))
CallError(stacktop,"defmodule: missing syntax spec",nil,NONCONTINUABLE);
syntax_specs = CAR(forms); forms = CDR(forms);
if (syntax_specs != nil)
CallError(stacktop,
"defmodule: non-null syntax spec",syntax_specs,NONCONTINUABLE);
/* Should do the loading here maybe... */ /* HACK !!! */
STACK_TMP(name);
module = allocate_i_module(stacktop,name);
/* Insert eval/cm and set/cm... */
STACK_TMP(module);
make_default_module_functions(stacktop,module);
UNSTACK_TMP(module);
/* recover import spec, etc */
forms =ARG_2(stackbase);
forms=CDR(forms);
import_specs = CAR(forms); forms = CDR(forms);
syntax_specs = CAR(forms); forms = CDR(forms);
ARG_2(stackbase)=forms;
STACK_TMP(module);
process_import_spec(stacktop,module,import_specs);
walker = ARG_2(stackbase)/*forms*/;
UNSTACK_TMP(module);
while (walker != nil) {
if (SYSTEM_GLOBAL_VALUE(load_verbosity) > 0) {
fprintf(StdOut->STREAM.handle,"Processing: ");
EUCALL_2(Fn_print, CAR(walker),StdOut);
}
STACK_TMP(CDR(walker));
STACK_TMP(module);
EUCALL_2(process_top_level_form,module,CAR(walker));
UNSTACK_TMP(module);
UNSTACK_TMP(walker);
}
UNSTACK_TMP(name);
STACK_TMP(module);
put_module(stacktop,name,module);
UNSTACK_TMP(module);
return(module);
}
EUFUN_CLOSE
EUFUN_3( Rf_loaded_modules, mod, env, val)
{
IGNORE(mod); IGNORE(env); IGNORE(val);
return(EUCALL_1(Fn_table_keys, global_module_table));
}
EUFUN_CLOSE
extern LispObject Fn_close(LispObject*);
EUFUN_3( Rf_load_module, mod, env, form)
{
IGNORE(mod); IGNORE(env);
if (!is_cons(form))
CallError(stacktop,"load-module: invalid arguments",form,NONCONTINUABLE);
RESET_GLOBAL_STACK();
return(EUCALL_1(load_module,CAR(form)));
}
EUFUN_CLOSE
EUFUN_3( Rf_reload_module, mod, env, form)
{
IGNORE(mod); IGNORE(env);
if (!is_cons(form))
CallError(stacktop,"reload-module: invalid arguments",form,NONCONTINUABLE);
/* Hack out original... */
EUCALL_3(tref_updator, global_module_table,CAR(form),nil);
return(EUCALL_1(load_module,CAR(ARG_2(stackbase))));
}
EUFUN_CLOSE
static LispObject open_module_file(LispObject *stacktop,LispObject name)
{
char path[200];
LispObject walker;
FILE *fd;
if (!is_symbol(name))
CallError(stacktop,
"open-module-file: not a symbolic name",name,NONCONTINUABLE);
walker = SYSTEM_GLOBAL_VALUE(list_search_path);
while (is_cons(walker)) {
LispObject dir;
if (!is_string((dir = CAR(walker))))
CallError(stacktop,
"open-module-file: bad search directory",dir,NONCONTINUABLE);
(void) strcpy(path,stringof(dir));
(void) strcat(path,"/");
(void) strcat(path,name->SYMBOL.pname);
(void) strcat(path,".em\0");
if ((fd = fopen(path,"r")) == NULL)
walker = CDR(walker);
else
return((LispObject) allocate_stream(stacktop,fd,'r'));
}
CallError(stacktop,"open-module-file: unable to find .em file for module",
name,NONCONTINUABLE);
return(nil);
}
EUFUN_1( load_module, name)
{
char fname[100];
LispObject stream,form,ans;
if (!is_symbol(name))
CallError(stacktop,
"load-module: non-symbolic module name",name,NONCONTINUABLE);
/* Look if it's already loaded */
if (module_loaded_p(stacktop,name)) return(get_module(stacktop,name));
stream = open_module_file(stacktop,name);
name=ARG_0(stackbase);
fprintf(StdOut->STREAM.handle,"Loading module '%s'\n",name->SYMBOL.pname);
EUCALLSET_1(form, Fn_read, stream);
#if 0
EUCALL_2(Fn_print,form,StdErr); fflush(stderr);
#endif
EUCALL_1(Fn_close, stream);
if (!is_cons(form))
CallError(stacktop,
"load module: invalid module definition",nil,NONCONTINUABLE);
if (CAR(form) != sym_defmodule)
CallError(stacktop,
"load module: invalid module definition",nil,NONCONTINUABLE);
if(!is_cons(CDR(form)))
CallError(stacktop,
"load module: invalid definintion",form,NONCONTINUABLE);
name=ARG_0(stackbase);
if (CAR(CDR(form)) != name)
CallError(stacktop,
"load module: module badly named",CAR(CDR(form)),NONCONTINUABLE);
EUCALLSET_3(ans,Rf_defmodule,NULL,NULL,CDR(form));
name=ARG_0(stackbase);
fprintf(StdOut->STREAM.handle,"Loaded '%s'\n",name->SYMBOL.pname);
return(ans);
}
EUFUN_CLOSE
LispObject load_expanded_module(LispObject *stacktop,LispObject name)
{
char fname[100];
LispObject stream,form;
if (!is_symbol(name))
CallError(stacktop,
"load-expanded-module: non-symbolic module name",name,NONCONTINUABLE);
/* Look if it's already loaded */
if (module_loaded_p(stacktop,name)) return(get_module(stacktop,name));
stream = open_module_file(stacktop,name);
/*
fprintf(stderr,"Starting read..."); fflush(stderr);
*/
fprintf(StdOut->STREAM.handle,"Loading module '%s'\n",name->SYMBOL.pname);
STACK_TMP(form);
OFF_collect();
EUCALLSET_1(form, Fn_read, stream);
ON_collect();
UNSTACK_TMP(form);
/*
fprintf(stderr,"Read complete.\n"); fflush(stderr);
*/
#if 0
EUCALL_2(Fn_print, form,StdErr); fflush(stderr);
#endif
STACK_TMP(form);
EUCALL_1(Fn_close, stream);
UNSTACK_TMP(form);
if (!is_cons(form))
CallError(stacktop,
"load module: invalid module definition",nil,NONCONTINUABLE);
if (CAR(form) != sym_defmodule)
CallError(stacktop,
"load module: invalid module definition",nil,NONCONTINUABLE);
if(!is_cons(CDR(form)))
CallError(stacktop,
"load module: invalid definintion",form,NONCONTINUABLE);
if (CAR(CDR(form)) != name)
CallError(stacktop,
"load module: module badly named",CAR(CDR(form)),NONCONTINUABLE);
return EUCALL_3(Rf_defmodule,NULL,NULL,CDR(form));
}
EUFUN_3( Rf_load_expanded_module, mod, env, forms)
{
if (!is_cons(forms))
CallError(stacktop,
"load-expanded-module: invalid arguments",forms,NONCONTINUABLE);
return(load_expanded_module(stacktop,CAR(forms)));
}
EUFUN_CLOSE
EUFUN_3( Rf_start_module, m, env, forms)
{
LispObject modname,fname;
LispObject mod;
if (!is_cons(forms))
CallError(stacktop,"start-module: invalid arguments",forms,NONCONTINUABLE);
modname = CAR(forms); forms = CDR(forms);
if (!is_symbol(modname))
CallError(stacktop,
"start-module: non-symbolic module name",modname,NONCONTINUABLE);
if (!is_cons(forms))
CallError(stacktop,
"start-module: missing function name",forms,NONCONTINUABLE);
fname = CAR(forms);
if (!is_symbol(fname))
CallError(stacktop,
"start-module: non-symbolic function name",fname,NONCONTINUABLE);
/* forms are hopefully (fname arg1 arg2 ...) */
/* semantically dubious but... */
mod = get_module(stacktop,modname);
if (mod == nil)
CallError(stacktop,
"start-module: module not loaded",modname,NONCONTINUABLE);
return(EUCALL_3(module_eval,mod,NULL,forms));
}
EUFUN_CLOSE
EUFUN_3( Rf_enter_module, m, env, form)
{
LispObject name;
LispObject mod;
if (!is_cons(form))
CallError(stacktop,"enter-module: invalid arguments",form,NONCONTINUABLE);
name = CAR(form);
if (!is_symbol(name))
CallError(stacktop,
"enter-module: non-symbolic module name",name,NONCONTINUABLE);
else {
mod = get_module(stacktop,name);
STACK_TMP(name);
if (mod == nil)
SYSTEM_GLOBAL_VALUE(current_interactive_module) =
EUCALL_1(load_module,name);
else
SYSTEM_GLOBAL_VALUE(current_interactive_module) = mod;
UNSTACK_TMP(name);
}
return(name);
}
EUFUN_CLOSE
EUFUN_0( Rf_load_quietly)
{
SYSTEM_GLOBAL_VALUE(load_verbosity) = 0;
return(nil);
}
EUFUN_CLOSE
EUFUN_0( Rf_load_loudly)
{
SYSTEM_GLOBAL_VALUE(load_verbosity) = 1;
return(nil);
}
EUFUN_CLOSE
static EUFUN_0( Fn_load_path)
{
return(SYSTEM_GLOBAL_VALUE(list_search_path));
}
EUFUN_CLOSE
static EUFUN_1( Fn_load_path_setter, val)
{
return((SYSTEM_GLOBAL_VALUE(list_search_path) = val));
}
EUFUN_CLOSE
static EUFUN_3( Rf_em, m, e, f)
{
return Rf_enter_module(stackbase);
}
EUFUN_CLOSE
static EUFUN_3( Rf_rem, m, e, f)
{
EUCALL_3(Rf_reload_module,m,e,f);
return Rf_enter_module(stackbase);
}
EUFUN_CLOSE
void initialise_root(LispObject* stacktop)
{
extern char *getenv(char *);
extern LispObject Fn_nconc(LispObject*);
char *path_list;
SYSTEM_INITIALISE_GLOBAL(int,load_verbosity,0);
SYSTEM_INITIALISE_GLOBAL(LispObject,list_search_path,nil);
ADD_SYSTEM_GLOBAL_ROOT(list_search_path);
/* Initialise the paths... */
path_list = getenv(LOAD_PATH_NAME);
if (path_list == NULL) {
SYSTEM_GLOBAL_VALUE(list_search_path)
= EUCALL_2(Fn_cons,
allocate_string(stacktop,MODULE_PATH,strlen(MODULE_PATH)),
SYSTEM_GLOBAL_VALUE(list_search_path));
SYSTEM_GLOBAL_VALUE(list_search_path)
= EUCALL_2(Fn_cons, allocate_string(stacktop,".",1),
SYSTEM_GLOBAL_VALUE(list_search_path));
}
else {
char *next;
next = strtok(path_list,":");
while (next != NULL) {
LispObject xx;
xx = allocate_string(stacktop,next,strlen(next));
EUCALLSET_2(xx, Fn_cons, xx,nil);
EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_search_path),
Fn_nconc,SYSTEM_GLOBAL_VALUE(list_search_path), xx);
next = strtok(NULL,":");
}
}
sym_eval_cm = get_symbol(stacktop,"eval/cm");
add_root(&sym_eval_cm);
sym_set_cm = get_symbol(stacktop,"set/cm");
add_root(&sym_set_cm);
{
extern LispObject my_make_special(LispObject *,char *,LispObject (*)());
(void) my_make_special(stacktop,"!>",Rf_em);
(void) my_make_special(stacktop,"!>>",Rf_rem);
}
open_module(stacktop,&Module_root,Module_root_values,"root",ROOT_ENTRIES);
(void) make_unexported_module_special(stacktop,"defmodule",Rf_defmodule);
(void) make_unexported_module_special(stacktop,"load-module",Rf_load_module);
(void) make_unexported_module_special(stacktop,
"reload-module",Rf_reload_module);
(void) make_unexported_module_special(stacktop,
"enter-module",Rf_enter_module);
(void) make_unexported_module_special(stacktop,
"loaded-modules",Rf_loaded_modules);
(void) make_unexported_module_special(stacktop,
"start-module",Rf_start_module);
(void) make_unexported_module_special(stacktop,"load-expanded-module",
Rf_load_expanded_module);
(void) make_unexported_module_special(stacktop,
"load-quietly",Rf_load_quietly);
(void) make_unexported_module_special(stacktop,"load-loudly",Rf_load_loudly);
(void) make_unexported_module_function(stacktop,"load-path",Fn_load_path,0);
(void) make_unexported_module_function(stacktop,"set-load-path",
Fn_load_path_setter,1);
{
extern LispObject union_filter(LispObject);
(void) make_module_function(stacktop,"filter",union_filter,1);
}
close_module();
}